home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 1463.ZIP / DRAW-2D.ARC / GETDIR.PAS < prev    next >
Pascal/Delphi Source File  |  1986-09-10  |  3KB  |  132 lines
  1. PROCEDURE GETDIR(TYP:STR4; VAR ICODE:INTEGER);
  2. (*   ICODE = 0   if files are found  *)
  3. (*   ICODE = 1   if no files on dev-path *)
  4.   CONST
  5.    GETDTA = 47;
  6.    GET1   = 78;
  7.    GETN   = 79;
  8.   VAR
  9.    MSG,DSTR:SCRLINE;
  10.    T:CHAR;
  11.    ECODE,K2,K,L:INTEGER;
  12.    FNUM:STRING[3];
  13.    FILNM,TEMP,FNAME2:STR12;
  14.    FX : ARRAY [1..256] OF STR12;
  15.    FNAME:FSTR;
  16.    FOUND:BOOLEAN;
  17.  PROCEDURE FINDDTA(VAR DTASEG,DTAOFS:INTEGER);
  18.    VAR
  19.      REGPAC : REGIS;
  20.    BEGIN
  21.      WITH  REGPAC  DO
  22.        BEGIN
  23.          AX := GETDTA*256;
  24.          MSDOS(REGPAC);
  25.          DTASEG := ES;
  26.          DTAOFS := BX;
  27.        END;
  28.    END;
  29.  FUNCTION GETNAM:STR12;
  30.    VAR
  31.      I,DTASEG,DTAOFS:INTEGER;
  32.      CH:CHAR;
  33.      RESULT:STR12;
  34.    BEGIN
  35.      FINDDTA(DTASEG,DTAOFS);
  36.      RESULT := '';
  37.      I := 30;
  38.      CH := CHR(MEM[DTASEG:DTAOFS+I]);
  39.      WHILE CH <> CHR(0) DO
  40.          BEGIN
  41.            RESULT := CONCAT(RESULT,CH);
  42.            I := I+1;
  43.            CH := CHR(MEM[DTASEG:DTAOFS+I]);
  44.          END;
  45.      GETNAM := RESULT;
  46.    END;
  47.  PROCEDURE DIR1(SOURCE:FSTR; VAR NEWFIL:STR12; VAR STATUS:BOOLEAN);
  48.    VAR
  49.      REGPAC : REGIS;
  50.      FLG    : BYTE;
  51.    BEGIN
  52.      SOURCE := CONCAT(SOURCE,CHR(0));
  53.      WITH REGPAC DO
  54.         BEGIN
  55.           AX := GET1*256;
  56.           DS := SEG(SOURCE);
  57.           DX := OFS(SOURCE)+1;
  58.         END;
  59.           MSDOS(REGPAC);
  60.           NEWFIL := '';
  61.           FLG := REGPAC.FLAGS AND 1;
  62.           IF FLG = 0 THEN
  63.              BEGIN
  64.                STATUS := TRUE;
  65.                NEWFIL := GETNAM;
  66.              END
  67.            ELSE
  68.              STATUS := FALSE;
  69.    END;
  70.  PROCEDURE DIRN(SOURCE:FSTR; VAR NEWFIL:STR12; VAR STATUS:BOOLEAN);
  71.    VAR
  72.      REGPAC : REGIS;
  73.      FLG    : BYTE;
  74.    BEGIN
  75.      SOURCE := CONCAT(SOURCE,CHR(0));
  76.      WITH REGPAC DO
  77.         BEGIN
  78.           AX := GETN*256;
  79.           DS := SEG(SOURCE);
  80.           DX := OFS(SOURCE)+1;
  81.         END;
  82.           MSDOS(REGPAC);
  83.           NEWFIL := '';
  84.           FLG := REGPAC.FLAGS AND 1;
  85.           IF FLG = 0 THEN
  86.              BEGIN
  87.                STATUS := TRUE;
  88.                NEWFIL := GETNAM;
  89.              END
  90.            ELSE
  91.              STATUS := FALSE;
  92.    END;
  93.   BEGIN
  94.     ICODE := 0;
  95.     FILNM := '*'+TYP;
  96.     FNAME :=  FILNM;
  97.     CLS;
  98.     K2 := 1;
  99.     K := 2;
  100.     DIR1(FNAME,FNAME2,FOUND);
  101.     IF FOUND THEN
  102.        BEGIN
  103.          CLS;
  104.          MOVCUR(1,25);
  105.          WRITELN('Drawing Files on Current Drive/Path');
  106.          MOVCUR(3,1);
  107.          L := POS('.',FNAME2);
  108.          TEMP := COPY(FNAME2,1,L-1);
  109.          WRITE(TEMP,' ':10-LENGTH(TEMP));
  110.          FX[K2] := TEMP;
  111.          WHILE FOUND DO
  112.             BEGIN
  113.               DIRN(FNAME,FNAME2,FOUND);
  114.               IF FOUND THEN
  115.                  BEGIN
  116.                    L := POS('.',FNAME2);
  117.                    TEMP := COPY(FNAME2,1,L-1);
  118.                    K2 := K2 + 1;
  119.                    WRITE(TEMP,' ':10-LENGTH(TEMP));
  120.                    FX[K2] := TEMP;
  121.                    K := K + 1;
  122.                    IF K > 5 THEN
  123.                      BEGIN
  124.                       K := 1;
  125.                       WRITELN;
  126.                      END;
  127.                  END;
  128.             END;
  129.        END
  130.      ELSE
  131.         ICODE := 1;
  132.   END;